home *** CD-ROM | disk | FTP | other *** search
/ Magnum One / Magnum One (Mid-American Digital) (Disc Manufacturing).iso / d18 / vis082s.arc / VISCHAT.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1991-04-18  |  8.6 KB  |  419 lines
  1. {$R-,S-,I-,D-,F+,V-,B-,N-,L+,O+ }
  2.  
  3. unit chatstuf;        (* Chat Mode and F2 Keys *)
  4.  
  5. procedure verticalchat; (gotospecial:boolean);
  6. var k:char;
  7.     StartedTime:Word;
  8.     cnt,displaywid:integer;
  9.     quit,carrierloss,fromkbd:boolean;
  10.     baudstr,commstr:mstr;
  11.     c1,c2,c3,c4,c5,c6,c7,c8,backup:integer;
  12.  
  13.  
  14.     xsys     :byte;
  15.     ysys     :byte;
  16.     xusr     :byte;
  17.     yusr     :byte;
  18.     curcolor :byte;
  19.     ec       :byte;
  20.     initi    :boolean;
  21.     linebufs :string[80];
  22.     linebufu :string[80];
  23.  
  24. procedure init;
  25. begin
  26.   xsys     :=1;
  27.   ysys     :=14;
  28.   xusr     :=1;
  29.   yusr     :=4;
  30.   curcolor :=1;
  31.   ec       :=1;
  32.   initi    :=true;
  33.   linebufs :='';
  34.   linebufu :='';
  35.   inuse:=2;
  36. end;
  37.  
  38.  
  39. procedure sendxy (x,y:byte);
  40. begin
  41.  write(#27+'[',y,';',x,'H');
  42.  
  43. end;
  44.  
  45.  
  46. Procedure clearscre;
  47.  var i:byte;
  48.  begin
  49.  for I:=4 to 22 do
  50.   begin
  51.    sendxy(1,i);
  52.    write(#27'[K');
  53.    end;
  54.  end;
  55.  
  56.  
  57. Procedure setc;
  58. begin
  59.    if fromkbd then ec:=urec.statcolor else ec:=urec.inputcolor;
  60.    if curcolor<>ec then begin
  61.    curcolor:=ec;
  62.   end;
  63. end;
  64.  
  65.  procedure midline;
  66.  var i:byte;
  67.  begin
  68.    sendxy(2,13);
  69.    write('────────────────────────────────────────┬────────────────────────────────────');
  70.    sendxy(trunc((21-length(configset.sysopnam))/2),1);
  71.    write (^R'■ '^S+configset.sysopnam+^R' ■');
  72.    sendxy(trunc((24-length(urec.handle))/2)+52,1);
  73.    write (^R'■ '^S+urec.handle+^R' ■');
  74.    For i:=4 to 25 Do Begin
  75.    Sendxy(i,40);
  76.    Write('│');
  77.  end;
  78.  
  79. Procedure cle (malig:byte);
  80. var i,x    :byte;
  81.  
  82. begin
  83. if malig=0 then
  84. begin
  85.   for i:=1 to 39 do Begin
  86.    for x:=4 to 25 do
  87.  begin
  88.     sendxy(i,x);
  89.     write(' ');
  90.  end;
  91.  sendxy(1,4);
  92.  malig:=0;
  93. end;
  94.  
  95. if malig=1 then
  96. begin
  97.  for i:=41 to 79 do begin
  98.   for x:=4 to 25 do
  99.  begin
  100.   sendxy(i,x);
  101.   write(#27,' ');
  102.  end;
  103.  sendxy(41,4);
  104.  malig:=0;
  105. end;
  106.  
  107.  
  108.  
  109. end;
  110.  
  111.   procedure wordwrapit(yeanea:byte);
  112.   var cnt       :byte;
  113.       wl        :integer;
  114.       ww        :lstr;
  115.       cutarea   :byte;
  116.       done      :boolean;
  117.   begin
  118.    done:=false;
  119.    cutarea:=0;
  120.    ww:='';
  121.    cnt:=39;
  122.    if yeanea=0 then
  123.      begin
  124.       If Pos(' ',LineBufs)<=0 then Begin
  125.         Writeln;
  126.         LineBufs:='';
  127.         Xsys:=1;
  128.         Inc(Ysys);
  129.         Exit;
  130.       End;
  131.     repeat
  132.       if not done and (copy(linebufs,cnt,1)=' ') then cutarea:=cnt;
  133.       if (cutarea>0) and not done then
  134.         begin
  135.         ww:=copy(linebufs,cnt+1,255);
  136.          ansicolor(urec.statcolor);
  137.          sendxy(cutarea,ysys);
  138.          write(#27'[K');
  139.          inc(ysys);
  140.          xsys:=1;
  141.          sendxy(xsys,ysys);
  142.          write(copy(linebufs,cutarea+1,80-cutarea));
  143.          xsys:=length(copy(linebufs,cutarea+1,80-cutarea))+1;
  144.          sendxy(xsys,ysys);
  145.          dec(ysys);
  146.          done:=true
  147.         end;
  148.       dec(cnt);
  149.      until cnt=1;
  150.     linebufs:=ww;
  151.    end;
  152.  
  153.    if yeanea=1 then
  154.    begin
  155.     If Pos(' ',LineBufu)<=0 then Begin
  156.        Writeln;
  157.        Inc(Yusr);
  158.        Xusr:=0;
  159.        LineBufu:='';
  160.        Exit;
  161.     End;
  162.    done:=false;
  163.    cutarea:=0;
  164.    ww:='';
  165.    cnt:=39;
  166.     repeat
  167.       if not done and (copy(linebufu,cnt,1)=' ') then cutarea:=cnt;
  168.       if (cutarea>0) and not done then
  169.         begin
  170.         ww:=copy(linebufu,cnt+1,255);
  171.          ansicolor(urec.inputcolor);
  172.          sendxy(cutarea,yusr);
  173.          write(#27'[K');
  174.          inc(yusr);
  175.          xusr:=1;
  176.          sendxy(xusr,yusr);
  177.          write(copy(linebufu,cutarea+1,39-cutarea));
  178.          xusr:=length(copy(linebufu,cutarea+1,39-cutarea))+1;
  179.          sendxy(xusr,yusr);
  180.          dec(yusr);
  181.          done:=true
  182.         end;
  183.       dec(cnt);
  184.      until cnt=1;
  185.     linebufu:=ww;
  186.    end;
  187.  
  188. end;
  189.  
  190.  
  191.  Procedure locate;
  192.  begin
  193.    if fromkbd then
  194.  begin
  195.  
  196.      if (xsys=40) and (ysys<24) then
  197.     begin
  198.      wordwrapit(0);
  199.      inc(ysys);
  200.     end;
  201.     if ((ysys=24) and (xsys=40)) or (ysys>24) then
  202.     begin
  203.     cle(0);
  204.     ysys:=4;
  205.     xsys:=1;
  206.     sendxy(xsys,ysys);
  207.     ansicolor(urec.statcolor);
  208.     write(linebufs);
  209.     sendxy(80-length(linebufs)+1,ysys);
  210.     wordwrapit(0);
  211.     inc(ysys);
  212.     sendxy(xsys,ysys);
  213.  end;
  214.  
  215.   sendxy(xsys,ysys);
  216.   inc(xsys);
  217.  end;
  218.    if not fromkbd then
  219.  begin
  220.    if (xusr=80) and (yusr<24) then
  221.   begin
  222.    wordwrapit(1);
  223.    inc(yusr);
  224.   end;
  225. if ((yusr=24) and (xusr=80)) or (yusr>24) then
  226.  begin
  227.    cle(1);
  228.    yusr:=4;
  229.    xusr:=41;
  230.    sendxy(xusr,yusr);
  231.    ansicolor(urec.inputcolor);
  232.    write(linebufu);
  233.    sendxy(80-length(linebufu)+1,yusr);
  234.    wordwrapit(1);
  235.    inc(yusr);
  236.    sendxy(xusr,yusr);
  237.  end;
  238.  
  239.    sendxy(xusr,yusr);
  240.    inc(xusr);
  241.  end;
  242. end;
  243.  
  244.   procedure instruct;
  245.   var i:integer;
  246.   begin
  247.     initi:=false;
  248.     sendxy(1,4);
  249.   end;
  250.  
  251.   Procedure ChangeVars;
  252.       Begin
  253.        backup:=c1;
  254.        c1:=c2; c2:=c3; c3:=c4; c4:=c5; c5:=c6; c6:=c7; c7:=c8; c8:=backup;
  255.        ansicolor(c1);
  256.       End;
  257.  
  258.     Procedure GetCrazyVars;
  259.       Begin
  260.        If CrazyChat Then Begin
  261.        c1:=configset.kkk1; c2:=configset.kkk2; c3:=configset.kkk3;
  262.        c4:=configset.kkk4; c5:=configset.kkk5; c6:=configset.kkk6;
  263.        c7:=configset.kkk7; c8:=configset.kkk8;
  264.       End Else Begin
  265.        c1:=urec.inputcolor;
  266.        End;
  267.       End;
  268.  
  269.  
  270. procedure typedchar (k:char);
  271.  
  272.    begin
  273.    ChangeVars;
  274.    locate;
  275.    begin;
  276.    if fromkbd then begin If Crazychat then ansicolor(c1) else ansicolor(urec.promptcolor); linebufs:=linebufs+K;
  277.    end;
  278.    if not fromkbd then begin If Crazychat then ansicolor(c1) else ansicolor(urec.inputcolor); linebufu:=linebufu+K;
  279.    end;
  280.     write(k)
  281.    end;
  282.   end;
  283.  
  284.  
  285. begin
  286.   carrierloss:=false;
  287.   chatmode:=false;
  288.   writeln (^B^M);
  289.   if wanted in urec.config then begin
  290.     specialmsg ('(No longer wanted)');
  291.     urec.config:=urec.config-[wanted];
  292.     writeurec;
  293.   end;
  294.   if eightycols in urec.config then displaywid:=80 else displaywid:=40;
  295.   if gotospecial then begin
  296.     specialseries;
  297.     exit
  298.   end;
  299.   clearbreak;
  300.   nobreak:=true;
  301.   writeln (^M^M,configset.entercha,^M^R);
  302.   StartedTime:=TimeLeft;
  303.   instruct;
  304.   if not initi then
  305. begin
  306.    whatkindofchat;
  307.    if crazychat then GetCrazyVars;
  308.    init;
  309.    clearscre;
  310.    midline;
  311. end;
  312.  
  313.   quit:=false;
  314.  
  315.   repeat
  316.     linecount:=0;
  317.     if (not carrierloss) and (not carrier) then begin
  318.       carrierloss:=true;
  319.       gotoxy(1,4);
  320.       writeln (^M'Warning: There is no carrier present.'^M)
  321.  
  322.     end;
  323.     repeat until keyhit or (carrier and (numchars>0));
  324.     fromkbd:=keyhit;
  325.     ingetstr:=true;
  326.  
  327.     read (directin,k);
  328.     if k=#127 then k:=#8;
  329.     if requestchat
  330.       then if requestcom
  331.         then
  332.           begin
  333.             quit:=specialcommand;
  334.             if not quit then instruct;
  335.             clearbreak;
  336.             nobreak:=true;
  337.           end
  338.         else
  339.           begin
  340.             unsplit;
  341.             writeln (^M^M,configset.exitcha,^M^R);
  342.         SetTimeLeft(StartedTime);
  343.         bottomline;
  344.         clearscre;
  345.             quit:=true
  346.           end;
  347.     case ord(k) of
  348.       8:begin
  349.       if (xsys>1) and fromkbd then
  350.        begin
  351.           modeminlock:=true;
  352.           if xsys>1 then dec(xsys);
  353.           sendxy(xsys,ysys);
  354.           write (' ');
  355.           sendxy(xsys,ysys);
  356.           if length(linebufs)>0 then linebufs:=copy(linebufs,1,length(linebufs)-1);
  357.           modeminlock:=false;
  358.         end;
  359.       if (xusr>1) and not fromkbd then
  360.        begin
  361.           modeminlock:=true;
  362.           if xusr>1 then dec(xusr);
  363.           sendxy(xusr+40,yusr);
  364.           write (' ');
  365.           sendxy(xsys,ysys);
  366.           if length(linebufu)>0 then linebufu:=copy(linebufu,1,length(linebufu)-1);
  367.           modeminlock:=false;
  368.         end;
  369.      end;
  370.       0:;
  371.       13:begin
  372.            writeln;
  373.            bottomline;
  374.           if fromkbd then begin
  375.            xsys:=1;
  376.            inc(ysys);
  377.        if (ysys>=24) then
  378.        begin
  379.        cle(0);
  380.        ysys:=4;
  381.        xsys:=1;
  382.        sendxy(xsys,ysys);
  383.        ansicolor(urec.statcolor);
  384.        write(linebufs);
  385.        ysys:=15;
  386.        xsys:=1;
  387.        end;
  388.        sendxy(xsys,ysys);
  389.        linebufs:='';
  390.        end;
  391.  
  392.           if not fromkbd then begin
  393.            xusr:=1;
  394.            inc(yusr);
  395.        if (yusr=24) then
  396.               begin
  397.                  cle(1);
  398.                   yusr:=4;
  399.                   xusr:=41;
  400.                    ansicolor(urec.inputcolor);
  401.                   sendxy(xusr,yusr);
  402.                   write(linebufu);
  403.                   yusr:=5;
  404.                   sendxy(xusr,yusr);
  405.               end;
  406.             sendxy(xusr,yusr);
  407.           linebufu:='';
  408.           end;
  409.          end;
  410.       32..255:typedchar (k);
  411.       1..31:if fromkbd and carrier then sendchar(k);
  412.     end
  413.   until quit;
  414.   clearbreak
  415. end;
  416.  
  417. begin
  418. end.
  419.